home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / boost4.arc / DEMO4.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-10-23  |  14.3 KB  |  520 lines
  1. Program Demo4;
  2.  
  3. {--------------------------------------------}
  4. {    Demo4                                   }
  5. {    Demonstrates many Boosters 4.0 routines }
  6. {                                            }
  7. {    Note: unit BOSHARE is a subset of the   }
  8. {    Boosters 4.0 library.                   }
  9. {                                            }
  10. {    Requires file Demo4.Gen, which contains }
  11. {    screens created with ScrGen16.          }
  12. {                                            }
  13. {    Written by George F. Smith              }
  14. {               609 Candlewick Lane          }
  15. {               Lilburn, GA 30247            }
  16. {               (404) 923-6879               }
  17. {                                            }
  18. {--------------------------------------------}
  19.  
  20. uses crt, dos, BOSHARE;
  21.  
  22. Type
  23.    TimeValues = array[1..6] of byte;
  24.    HexValues  = array[1..3] of word;
  25.  
  26. Const
  27.    Boxbg : array[1..4] of byte = ($1E,$4E,$6E,$5E);
  28.    days  : array[0..6] of String =
  29.            ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday',
  30.             'Saturday');
  31.    quit   = #27;
  32.    start  = #13;
  33.    npage  = 4;
  34.  
  35. var
  36.    Page : array[1..npage] of HeapBuf;
  37.  
  38.    hour,
  39.    min,
  40.    sec,
  41.    i, j, n,
  42.    x1, y1,
  43.    x2, y2,
  44.    ecode   : integer;
  45.    size    : longint;
  46.    c       : char;
  47.    s       : String;
  48.    tod     : TimeValues;
  49.    HexTime : HexValues;
  50.  
  51. { ---------------- }
  52. { End the demo     }
  53. { ---------------- }
  54. Procedure EndDemo;
  55. begin
  56.    ClrScr;
  57.    halt;
  58. end;   { EndDemo }
  59.  
  60. { ------------------- }
  61. { Wait for a keypress }
  62. { ------------------- }
  63. Procedure Pause;
  64. begin
  65.    Pdq('e',Center('Press any key to continue, ESC to quit', 80,' '),1, 25, 11 );
  66.    repeat until KeyPressed;
  67.    c := readkey;
  68.    if c = quit then
  69.       EndDemo
  70.    else if KeyPressed then begin
  71.       c := readkey;
  72.       if c = #0 then
  73.          c := readkey;
  74.    end;
  75. end;   { Pause }
  76.  
  77. { -------------------------------------------- }
  78. { Get the system time and set up the big clock }
  79. { -------------------------------------------- }
  80. Procedure GetTime ( var TimeArray : timevalues; var B16Time : HexValues );
  81. begin
  82.    with regs do
  83.    begin
  84.       { Get current system time from DOS }
  85.       ax := $2C00;
  86.       intr($21,regs);
  87.  
  88.       { Demilitarize time }
  89.       if ch < 1 then
  90.          ch := 12
  91.       else
  92.       if ch > 12 then
  93.          ch := ch - 12;
  94.      TimeArray[1] := ch div 10;
  95.      TimeArray[2] := ch mod 10;
  96.      TimeArray[3] := cl div 10;
  97.      TimeArray[4] := cl mod 10;
  98.      TimeArray[5] := dh div 10;
  99.      TimeArray[6] := dh mod 10;
  100.      B16Time[1]   := ch;
  101.      B16Time[2]   := cl;
  102.      B16Time[3]   := dh;
  103.    end;
  104. end { GetTime };
  105.  
  106. { ----------------------------- }
  107. { make STR procedure a function }
  108. { ----------------------------- }
  109. function Fstr ( num : longint; width : integer) : String;
  110. var
  111.    s : string[80];
  112. begin
  113.    str ( num:width, s );
  114.    fstr := s;
  115. end;   { fstr }
  116.  
  117. BEGIN { demo }
  118.  
  119.    {--- Show opening screen }
  120.    ClrScr;
  121.    Box ( 20, 6, 60, 13, 1, 14 );
  122.    SetAtt ( 20, 6, 60, 13, 30 );
  123.    CtrScr ( 'e', 'Boosters 4.0 Shareware Demo',39,21,7,30);
  124.    CtrScr ( 'e', 'Snow removal is INACTIVE',39,21,9,30);
  125.    CtrScr ( 'e', 'Press <ENTER> to continue',39,21,11,30);
  126.  
  127.    {--- Find 'INACTIVE' on the screen and make it blink }
  128.    FindStr ( 21, 9, 'INACTIVE', 0, ecode );
  129.    if ecode = 0 then
  130.       SetAtt ( WhereX, WhereY,WhereX+7, WhereY, 158 )
  131.    else
  132.       EndDemo;
  133.  
  134.    {--- Wait for ENTER to start or another key to quit }
  135.    c := readkey;
  136.    if c <> Start then
  137.       EndDemo;
  138.  
  139.    {--- reserve heap space for NPAGE pages }
  140.    Mark(HeapTop);
  141.    for i := 1 to npage do
  142.       New ( page[i] );
  143.  
  144.    {--- load screens 1 through 3 from Demo4.Gen, }
  145.    {--- beginning on page 2 of the heap }
  146.    Fil2Heap ( 'Demo4.Gen',1,3,page[2],ecode );
  147.    if ecode <> 0 then begin
  148.       CtrScr ( 'e', 'Can''t find file ''Demo4.Gen''',80,1,1,30 );
  149.       halt;
  150.    end;
  151.  
  152.    {--- pop screen 1 of Demo4.Gen to the video display }
  153.    RestoreScreen ( Page[2] );
  154.    pause;
  155.  
  156.    {--- display some boxes with different colors }
  157.    ClrScr;
  158.    for i := 1 to 4 do
  159.    begin
  160.       x1 := 1 + (i-1) * 20;
  161.       y1 := 1;
  162.       x2 := x1 + 19;
  163.       y2 := 10;
  164.       Box ( x1, y1, x2, y2, 4, 14 );
  165.       PutStr (h,
  166.               Center('SetAtt',18,' '),x1+1,5,14);
  167.       SetAtt ( x1, y1, x2, y2, boxbg[i] );
  168.    end;
  169.  
  170.    PutStr ( h,Center('Greetings from Boosters',80 ,' '),1,12 ,14);
  171.    PutStr ( h,Center(' Version 4.0 ',80,' '),1,13,14);
  172.    PutStr ( h,
  173.             Center(' Running under Turbo Pascal 4.0 as a unit ',80,'-'),
  174.             1,15,14);
  175.    pause;
  176.  
  177.    {--- Move the boxes }
  178.    MoveBlk ( 1, 12, 80, 15, 1, 19 );
  179.    SaveScreen ( Page[1] );
  180.    HeapAtt  ( Page[1], 1, 1, 80, 14, 0 );
  181.    Heap2scr ( Page[1], 1, 1, 80, 14, 1, 1 );
  182.    pause;
  183.  
  184.    {--- Change video attributes of boxes }
  185.    for i := 1 to 4 do
  186.    begin
  187.       x1 := 1 + (i-1) * 20;
  188.       y1 := 1;
  189.       x2 := x1 + 19;
  190.       y2 := 10;
  191.       PutStr (h,
  192.               Center('ChgAtt',18,' '),x1+1,5,boxbg[i] );
  193.       ChgAtt ( x1, y1, x2, y2, 0, boxbg[i] );
  194.    end;
  195.    pause;
  196.  
  197.    {--- Create a tree image }
  198.    ClrScr;
  199.    for i := 1 to 22 do
  200.    begin
  201.       x1 := 1 + (i-1) * 2;
  202.       PutStr ( h, Center(Copies('░',x1),80,' '),1, i, 14 );
  203.    end;
  204.    pause;
  205.  
  206.    {--- Make tree go away by saving it to the heap & clearing screen }
  207.    SaveScreen ( Page[1] );
  208.    ClrScr;
  209.    pause;
  210.  
  211.    {--- Bring tree back from the heap }
  212.    RestoreScreen ( Page[1] );
  213.    pause;
  214.  
  215.    {--- remove a portion of the tree with Remblkr }
  216.    box ( 1, 10, 80, 14, 1, 30 );
  217.    Remblkr ( 2, 11, 79, 13, 30 );
  218.    PutStr ( h,'Remblkr',37,12,30);
  219.    pause;
  220.  
  221.    {--- Do the same with RemBlk }
  222.    Remblk (1, 10, 80, 14 );
  223.    PutStr ( h,'Remblk',38,12,14);
  224.    pause;
  225.  
  226.    {--- launch the tree }
  227.    ClrScr;
  228.    for i := 22 downto 2 do
  229.    begin
  230.       MblkHeap ( Page[1], 18, 2, 65, i, 18, 1 );
  231.       RestoreScreen ( Page[1] );
  232.    end;
  233.    Heap2Scr ( Page[1], 1, 2, 80, 2, 1, 1 );
  234.    pause;
  235.  
  236.    {--- Set up an image using RIGHT & LEFT }
  237.    ClrScr;
  238.    for i := 1 to 22 do
  239.    begin
  240.       x1 := 1 + (i-1) * 2;
  241.       PutStr ( h,right(Copies('░',x1),80,' '),1 ,i, 14 );
  242.       PutStr ( h, left(Copies('░',x1),80-x1,' '),1 ,i, 14 );
  243.    end;
  244.    pdq ('e', '[ LEFT ]',1,8,112);
  245.    pdq ('e', '[ RIGHT ]',72,8,112);
  246.    pause;
  247.  
  248.    {--- strip away the numbers, front and back }
  249.    s := '.......111111122222223333333$trip function333333322222221111111.......';
  250.    ClrScr;
  251.    ctrscr ( 'e',s, 80, 1, 1, 14 );
  252.    GetStr ( h, s, 1, 1, 80 );
  253.    n := lastPos('$',s,length(s) );
  254.    setatt ( n,1,n,1,112 );   { highlight the $ }
  255.    s := strip(s,' ');
  256.    s := strip(s,'.');
  257.    ctrscr( 'e', s, 80, 1, 2, 11 );
  258.    s := strip(s,'1');
  259.    ctrscr( 'e', s, 80, 1, 3, 11 );
  260.    s := strip(s,'2');
  261.    ctrscr( 'e', s, 80, 1, 4, 11 );
  262.    s := strip(s,'3');
  263.    ctrscr( 'e', s, 80, 1, 5, 11 );
  264.    s := copies(s[lastPos('$',s,length(s) )],80 );
  265.    putstr (h, s, 1, 7, Getatt( n, 1) );
  266.    ctrscr ('e', '[ CtrScr, LastPos, Strip ]', 80, 1, 9, 30 );
  267.    pause;
  268.  
  269.    {--- Create some boxes using BOXHEAP, then fire them to the screen }
  270.    ClrScr;
  271.    SaveScreen ( Page[1] );
  272.    Randomize;
  273.    for i := 1 to 8 do
  274.    begin
  275.       x1 := 1 + (i-1)*10;
  276.       x2 := x1 + 9;
  277.       y1 := 1;
  278.       y2 := 10;
  279.       BoxHeap ( Page[1],x1,y1,x2,y2,1+random(4),14 );
  280.       y1 := 15;
  281.       y2 := 24;
  282.       BoxHeap ( Page[1],x1,y1,x2,y2,1+random(4),14 );
  283.    end;
  284.    RestoreScreen ( Page[1] );
  285.    pdq ( 'e',Center('* * *  BoxHeap  * * *',80,' '),1, 12, 30 );
  286.    pdq ( 'e',Center('Jan. 1, 1989 is a '+Dows(1,1,1989),80,' '),1,13,14);
  287.    n := dow(8,15,1981);
  288.    s := days[n];
  289.    pdq ( 'e',Center('Aug. 15, 1981 is a '+s,80,' '),1,14,14);
  290.    pause;
  291.  
  292.    {--- Create more boxes, using boxheap and cblkheap }
  293.    ClrScr;
  294.    Scr2Heap ( page[1],1,1,80,25,1,1 );
  295.    for i := 0 to 7 do
  296.       putstr ( h, fstr(i,1)+copies('-',9), 1+i*10, 1, 14 );
  297.    boxheap ( page[1], 1, 2, 10, 6, 4, 14 );
  298.    for i := 1 to 7 do
  299.       cblkheap ( page[1], 1, 2, 10, 6, 11+(i-1)*10, 2 );
  300.    cblkheap ( page[1], 1, 2, 80, 6, 1, 8 );
  301.    cblkheap ( page[1], 1, 8, 80, 12, 1, 14 );
  302.    cblkheap ( page[1], 1, 14, 80, 18, 1, 20 );
  303.    heap2scr ( page[1], 1, 2, 80, 24, 1, 2 );
  304.    pause;
  305.  
  306.    {--- Circumnavigate the screen using MoveBg on the lower left box }
  307.    Fillheap ( page[1], 1, 20, 10, 24, ' ', 14 );
  308.    box ( 1, 20, 10, 24, 4, 112 );
  309.    pdq ( 'e',' MOVEBG ', 2, 22, 14 );
  310.    delay(500);
  311.    for i := 1 to 70 do
  312.       movebg ( page[1], i, 20, i+9, 24, i+1, 20 );
  313.    for i := 20 downto 3 do
  314.       movebg ( page[1], 71, i, 80, i+4, 71, i-1 );
  315.    for i := 71 downto 2 do
  316.       movebg ( page[1], i, 2, i+9, 6, i-1, 2 );
  317.    for i := 2 to 19 do
  318.       movebg ( Page[1], 1, i, 10, i+4, 1, i+1 );
  319.    delay(500);
  320.    box ( 1, 20, 10, 24, 4, 14 );
  321.    pause;
  322.  
  323.    {--- Circumnavigate the screen using MoveBlkr, sweeping its trail clean }
  324.    box ( 1, 20, 10, 24, 4, 112 );
  325.    pdq ( 'e','MOVEBLKR', 2, 22, 14 );
  326.    delay(500);
  327.    for i := 1 to 70 do
  328.       moveblkr ( i, 20, i+9, 24, i+1, 20, 30 );
  329.    for i := 20 downto 3 do
  330.       moveblkr ( 71, i, 80, i+4, 71, i-1, 30 );
  331.    for i := 71 downto 2 do
  332.       moveblkr ( i, 2, i+9, 6, i-1, 2, 30 );
  333.    for i := 2 to 19 do
  334.       moveblkr ( 1, i, 10, i+4, 1, i+1, 30 );
  335.    delay(500);
  336.    box ( 1, 20, 10, 24, 4, 14 );
  337.    pause;
  338.  
  339.    {--- Clear the heap and write it to the display }
  340.    fillheap ( page[1], 1, 1, 80, 25, ' ', 14 );
  341.    heap2scr ( page[1], 1, 1, 80, 25, 1, 1 );
  342.  
  343.    {--- Write a cross-hatch pattern on the screen }
  344.    s := copystr('█▄',40);
  345.    n := cntch(S,'█');
  346.    for i := 1 to 25 do
  347.       pdq ( 'e', s, 1, i, 7 );
  348.    putstr ( h, Center(' COPYSTR ',80,'░'),1,12,14);
  349.    pdq ( 'e', Center(' CNTCH('+fstr(n,2)+') ',80,'▒'),1,13,14 );
  350.    diffone ( 'e' );
  351.    write('>');
  352.    pause;
  353.  
  354.    {--- Clear lower half of the screen }
  355.    heap2scr ( page[1], 1, 14, 80, 25, 1, 14 );
  356.    pause;
  357.  
  358.    {--- Copy top half of screen to bottom half }
  359.    pdq ('e', Center(' COPYBLK ',80,'▒'), 1, 13, 14 );
  360.    copyblk ( 1, 1, 80, 11, 1, 14 );
  361.    pause;
  362.  
  363.    {--- Show a big clock }
  364.    s := copies(#196,80);
  365.    clrscr;
  366.    for i := 1 to 4 do
  367.    begin
  368.       pdq ( 'e', s, 1, i, 14 );
  369.       pdq ('e', s, 1, i + 20, 14 );
  370.    end;
  371.    box ( 8,6,73,19,1,14 );
  372.  
  373.    repeat
  374.       GetTime ( tod, HexTime );
  375.  
  376.       for i := 1 to 2 do
  377.       begin
  378.          x1 := 1 +tod[i] * 8;
  379.          x2 := x1 + 7;
  380.          heap2scr ( page[3], x1, 1, x2, 8, 9+(i-1)*8, 9 );
  381.       end;
  382.       heap2scr ( page[3], 1, 9, 8, 16, 25, 9 );
  383.  
  384.       for i := 3 to 4 do
  385.       begin
  386.          x1 := 1 +tod[i] * 8;
  387.          x2 := x1 + 7;
  388.          heap2scr ( page[3], x1, 1, x2, 8, 17+(i-1)*8, 9 );
  389.       end;
  390.       heap2scr ( page[3], 1, 9, 8, 16, 49, 9 );
  391.  
  392.       for i := 5 to 6 do
  393.       begin
  394.          x1 := 1 +tod[i] * 8;
  395.          x2 := x1 + 7;
  396.          heap2scr ( page[3], x1, 1, x2, 8, 25+(i-1)*8, 9 );
  397.       end;
  398.  
  399.       {--- Show time in hex }
  400.       ctrscr ( 'e', right(stripr(hex(hextime[1]),'l','0'),2,'0')+':'+
  401.                     right(stripr(hex(hextime[2]),'l','0'),2,'0')+':'+
  402.                     right(stripr(hex(hextime[3]),'l','0'),2,'0'),80,1,20,30 );
  403.  
  404.       {--- Show time in binary }
  405.       s[0] := #18;  { set length }
  406.       for i := 1 to 4 do
  407.          s[5-i]  := chr(48 + hextime[1] shr (i-1) and 1);
  408.       s[5] := ':';
  409.       for i := 1 to 6 do
  410.          s[12-i] := chr(48 + hextime[2] shr (i-1) and 1);
  411.       s[12] := ':';
  412.       for i := 1 to 6 do
  413.          s[19-i] := chr(48 + hextime[3] shr (i-1) and 1);
  414.       ctrscr ( 'e', s, 80, 1, 5, 30 );
  415.  
  416.    until keypressed;
  417.    if KeyPressed then begin
  418.       c := readkey;
  419.       if c = #0 then c := readkey;
  420.    end;
  421.  
  422.    {--- Create random patterns on the screen and search for 'EE' }
  423.    Randomize;
  424.    ClrScr;
  425.    s[0] := #1;
  426.    for i := 1 to 25 do
  427.       for n := 1 to 80 do
  428.       begin
  429.          s[1] := chr(65+random(10));
  430.          pdq ('e',s,n,i,7);
  431.       end;
  432.    x1 := 1;
  433.    y1 := 1;
  434.    s := 'EE';
  435.    repeat
  436.       findstr ( x1,y1,s,0,ecode );
  437.       if ecode = 0 then
  438.          setatt ( wherex, wherey, wherex+length(s)-1, wherey, 30 );
  439.       x1 := wherex + 2;
  440.       y1 := wherey;
  441.    until (ecode > 0) or (y1 = 25);
  442.    ctrscr ( 'e', '<  F I N D S T R  >',80,1,12,14 );
  443.    pause;
  444.  
  445.    {--- Report number of occurrences of 'EE' }
  446.    SaveScreen ( Page[1] );
  447.    ClrScr;
  448.    CtrScr ('e','<< F S T R H E A P >>',80,1,1,30 );
  449.    pdq ('e',S+' was found at the following coordinates:',1,2,14);
  450.    x1 := 1;
  451.    y1 := 1;
  452.    i := 3;
  453.    repeat
  454.       fstrheap ( Page[1], s, x1, y1, ecode );
  455.       if ecode = 0 then
  456.       begin
  457.          pdq ('e','('+fstr(x1,2)+','+fstr(y1,2)+')',10,i,14 );
  458.          getheap ( Page[1], h, s, x1, y1, length(s) );
  459.          pdq ('e', s + ' (fetched by Getheap)', 18, i, 14 );
  460.       end;
  461.       i := i + 1;
  462.       x1 := x1+length(s);
  463.    until ecode > 0;
  464.    pause;
  465.  
  466.    {--- Propagate message on line 25 using GetAtt, GetChar }
  467.    repeat
  468.       for i := 25 downto 2 do
  469.          for j := 1 to 80 do
  470.             pdq ('e',getchar(j,i), j, i-1, getatt(j,i) );
  471.       for i := 25 downto 2 do
  472.          pdq ('e',copies(' ',80),1, i, getatt(j,i) );
  473.       for i := 1 to 24 do
  474.          for j := 1 to 80 do
  475.             pdq ('e',getchar(j,i), j, i+1, getatt(j,i) );
  476.       for i := 1 to 24 do
  477.          pdq ('e',copies(' ',80),1, i, getatt(j,i) );
  478.    until keypressed;
  479.    if KeyPressed then begin
  480.      c := readkey;
  481.      if c = #0 then c := readkey;
  482.    end;
  483.  
  484.    {--- Tell user what we did }
  485.    ctrscr ('e','A little bounce using ', 80,1,11,30 );
  486.    ctrscr ('e','   GETCHAR & GETATT   ',80,1,12,30 );
  487.    pause;
  488.  
  489.    {--- Create a pattern using Rword }
  490.    ClrScr;
  491.    s := 'Rword Try Rword';
  492.    PutStr(h,Center(S,80,' '),1,1,14);
  493.    for i := 0 to 20 do
  494.       PutStr ( h,Center(Rword(S,2,Copies('-',1+i*2)),80,' '),1,i+2,14 );
  495.    pause;
  496.  
  497.    {--- Using the Space function }
  498.    ClrScr;
  499.    s := 'Space Space';
  500.    for i := 10 downto 0 do
  501.       PutStr ( h,Center(Space(S,i+i*5,'░'),80,' '),1,11-i,14 );
  502.    for i := 1 to 10 do
  503.       PutStr ( h,Center(Space(S,i+i*5,'░'),80,' '),1,11+i,14 );
  504.    pause;
  505.  
  506.    {--- Some elementary heap manipulation }
  507.    RestoreScreen ( Page[1] );
  508.    CtrScr ( 'e','Current Page 1 of Heap',80,1,1,112 );
  509.    pause;
  510.    CopyHeap ( Page[2],Page[1],1,1,80,25,1,1 );
  511.    RestoreScreen ( Page[1] );
  512.    CtrScr ( 'e','After Copying Page 2 to Page 1 using CopyHeap',80,1,1,112);
  513.    pause;
  514.  
  515.    ClrScr;
  516.  
  517.    Release ( HeapTop );
  518.  
  519. END.   { Demo4 }
  520.